home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / slots-boot.lisp < prev    next >
Lisp/Scheme  |  1992-12-21  |  16KB  |  410 lines
  1. ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package :pcl)
  29.  
  30. (defmacro slot-symbol (slot-name type)
  31.   `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
  32.        (or (get ,slot-name ',(ecase type
  33.                    (reader 'reader-symbol)
  34.                    (writer 'writer-symbol)
  35.                    (boundp 'boundp-symbol)))
  36.        (intern (format nil "~A ~A slot ~a" 
  37.                (package-name (symbol-package ,slot-name))
  38.                (symbol-name ,slot-name)
  39.                ,(symbol-name type))
  40.                *slot-accessor-name-package*))
  41.        (progn 
  42.      (error "non-symbol and non-interned symbol slot name accessors~
  43.                  are not yet implemented")
  44.      ;;(make-symbol (format nil "~a ~a" ,slot-name ,type))
  45.      )))
  46.  
  47. (defun slot-reader-symbol (slot-name)
  48.   (slot-symbol slot-name reader))
  49.  
  50. (defun slot-writer-symbol (slot-name)
  51.   (slot-symbol slot-name writer))
  52.  
  53. (defun slot-boundp-symbol (slot-name)
  54.   (slot-symbol slot-name boundp))
  55.  
  56. (defmacro asv-funcall (sym slot-name type &rest args)
  57.   (declare (ignore type))
  58.   `(if (#-akcl fboundp #+akcl %fboundp ',sym)
  59.        (,sym ,@args)
  60.        (no-slot ',sym ',slot-name)))
  61.  
  62. (defun no-slot (slot-name sym)
  63.   (error "No class has a slot named ~S (~s has no function binding)
  64.           (or maybe your files were compiled with an old version of PCL:~
  65.           try recompiling.)"
  66.      slot-name sym))
  67.  
  68. (defmacro accessor-slot-value (object slot-name)
  69.   (unless (constantp slot-name)
  70.     (error "~s requires its slot-name argument to be a constant" 
  71.        'accessor-slot-value))
  72.   (let* ((slot-name (eval slot-name))
  73.      (sym (slot-reader-symbol slot-name)))
  74.     `(asv-funcall ,sym ,slot-name reader ,object)))
  75.  
  76. (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  77.   (unless (constantp slot-name)
  78.     (error "~s requires its slot-name argument to be a constant" 
  79.        'accessor-set-slot-value))
  80.   (setq object (macroexpand object env))
  81.   (setq slot-name (macroexpand slot-name env))
  82.   (let* ((slot-name (eval slot-name))
  83.      (bindings (unless (or (constantp new-value) (atom new-value))
  84.              (let ((object-var (gensym)))
  85.                (prog1 `((,object-var ,object))
  86.              (setq object object-var)))))
  87.      (sym (slot-writer-symbol slot-name))
  88.      (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
  89.     (if bindings
  90.     `(let ,bindings ,form)
  91.     form)))
  92.  
  93. (defconstant *optimize-slot-boundp* nil)
  94.  
  95. (defmacro accessor-slot-boundp (object slot-name)
  96.   (unless (constantp slot-name)
  97.     (error "~s requires its slot-name argument to be a constant" 
  98.        'accessor-slot-boundp))
  99.   (let* ((slot-name (eval slot-name))
  100.      (sym (slot-boundp-symbol slot-name)))
  101.     (if (not *optimize-slot-boundp*)
  102.     `(slot-boundp-normal ,object ',slot-name)
  103.     `(asv-funcall ,sym ,slot-name boundp ,object))))
  104.  
  105.  
  106. (defun structure-slot-boundp (object)
  107.   (declare (ignore object))
  108.   t)
  109.  
  110. (defun make-structure-slot-boundp-function (slotd)
  111.   (let* ((reader (slot-definition-internal-reader-function slotd))
  112.      (fun #'(lambda (object)
  113.           (not (eq (funcall reader object) *slot-unbound*)))))
  114.     (declare (type function reader))
  115.     #+(and kcl turbo-closure) (si:turbo-closure fun)
  116.     fun))            
  117.  
  118. (defun get-optimized-std-accessor-method-function (class slotd name)
  119.   (if (structure-class-p class)
  120.       (ecase name
  121.     (reader (slot-definition-internal-reader-function slotd))
  122.     (writer (slot-definition-internal-writer-function slotd))
  123.     (boundp (make-structure-slot-boundp-function slotd)))
  124.       (let* ((fsc-p (cond ((standard-class-p class) nil)
  125.               ((funcallable-standard-class-p class) t)
  126.               (t (error "~S is not a standard-class" class))))
  127.          (slot-name (slot-definition-name slotd))
  128.          (index (slot-definition-location slotd))
  129.          (function (ecase name
  130.              (reader #'make-optimized-std-reader-method-function)
  131.              (writer #'make-optimized-std-writer-method-function)
  132.              (boundp #'make-optimized-std-boundp-method-function)))
  133.          (value (funcall function fsc-p slot-name index)))
  134.     (declare (type function function))
  135.     (values value index))))
  136.  
  137. (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
  138.   (declare #.*optimize-speed*)
  139.   (set-function-name
  140.    (etypecase index
  141.      (fixnum (if fsc-p
  142.          #'(lambda (instance)
  143.              (let ((value (%instance-ref (fsc-instance-slots instance) index)))
  144.                (if (eq value *slot-unbound*)
  145.                (slot-unbound (class-of instance) instance slot-name)
  146.                value)))
  147.          #'(lambda (instance)
  148.              (let ((value (%instance-ref (std-instance-slots instance) index)))
  149.                (if (eq value *slot-unbound*)
  150.                (slot-unbound (class-of instance) instance slot-name)
  151.                value)))))
  152.      (cons   #'(lambda (instance)
  153.          (let ((value (cdr index)))
  154.            (if (eq value *slot-unbound*)
  155.                (slot-unbound (class-of instance) instance slot-name)
  156.                value)))))
  157.    `(reader ,slot-name)))
  158.  
  159. (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
  160.   (declare #.*optimize-speed*)
  161.   (set-function-name
  162.    (etypecase index
  163.      (fixnum (if fsc-p
  164.          #'(lambda (nv instance)
  165.              (setf (%instance-ref (fsc-instance-slots instance) index) nv))
  166.          #'(lambda (nv instance)
  167.              (setf (%instance-ref (std-instance-slots instance) index) nv))))
  168.      (cons   #'(lambda (nv instance)
  169.          (declare (ignore instance))
  170.          (setf (cdr index) nv))))
  171.    `(writer ,slot-name)))
  172.  
  173. (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
  174.   (declare #.*optimize-speed*)
  175.   (set-function-name
  176.    (etypecase index
  177.      (fixnum (if fsc-p
  178.          #'(lambda (instance)
  179.              (not (eq *slot-unbound*
  180.                   (%instance-ref (fsc-instance-slots instance) index))))
  181.          #'(lambda (instance)
  182.              (not (eq *slot-unbound* 
  183.                   (%instance-ref (std-instance-slots instance) index))))))
  184.      (cons   #'(lambda (instance)
  185.          (declare (ignore instance))
  186.          (not (eq *slot-unbound* (cdr index))))))
  187.    `(boundp ,slot-name)))
  188.  
  189. (defun make-optimized-structure-slot-value-using-class-method-function (function)
  190.   #+cmu (declare (type function function))
  191.   #'(lambda (class object slotd)
  192.       (let ((value (funcall function object)))
  193.     (if (eq value *slot-unbound*)
  194.         (slot-unbound class object (slot-definition-name slotd))
  195.         value))))        
  196.  
  197. (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
  198.   #+cmu (declare (type function function))
  199.   #'(lambda (nv class object slotd)
  200.       (declare (ignore class slotd))
  201.       (funcall function nv object)))
  202.  
  203. (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
  204.   #+cmu (declare (type function function))
  205.   #'(lambda (class object slotd)
  206.       (declare (ignore class slotd))
  207.       (not (eq (funcall function object) *slot-unbound*))))
  208.  
  209. (defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
  210.   (if (structure-class-p class)
  211.       (ecase name
  212.     (reader (make-optimized-structure-slot-value-using-class-method-function
  213.          (slot-definition-internal-reader-function slotd)))
  214.     (writer (make-optimized-structure-setf-slot-value-using-class-method-function
  215.          (slot-definition-internal-writer-function slotd)))
  216.     (boundp (make-optimized-structure-slot-boundp-using-class-method-function
  217.          (slot-definition-internal-writer-function slotd))))
  218.       (let* ((fsc-p (cond ((standard-class-p class) nil)
  219.               ((funcallable-standard-class-p class) t)
  220.               (t (error "~S is not a standard-class" class))))
  221.          (slot-name (slot-definition-name slotd))
  222.          (index (slot-definition-location slotd))
  223.          (function 
  224.           (ecase name
  225.         (reader 
  226.          #'make-optimized-std-slot-value-using-class-method-function)
  227.         (writer 
  228.          #'make-optimized-std-setf-slot-value-using-class-method-function)
  229.         (boundp 
  230.          #'make-optimized-std-slot-boundp-using-class-method-function))))
  231.     #+cmu (declare (type function function))
  232.     (values (funcall function fsc-p slot-name index) index))))
  233.  
  234. (defun make-optimized-std-slot-value-using-class-method-function
  235.     (fsc-p slot-name index)
  236.   (declare #.*optimize-speed*)
  237.   (etypecase index
  238.     (fixnum (if fsc-p
  239.         #'(lambda (class instance slotd)
  240.             (declare (ignore slotd))
  241.             (unless (fsc-instance-p instance) (error "not fsc"))
  242.             (let ((value (%instance-ref (fsc-instance-slots instance) index)))
  243.               (if (eq value *slot-unbound*)
  244.               (slot-unbound class instance slot-name)
  245.               value)))
  246.         #'(lambda (class instance slotd)
  247.             (declare (ignore slotd))
  248.             (unless (std-instance-p instance) (error "not std"))
  249.             (let ((value (%instance-ref (std-instance-slots instance) index)))
  250.               (if (eq value *slot-unbound*)
  251.               (slot-unbound class instance slot-name)
  252.               value)))))
  253.     (cons   #'(lambda (class instance slotd)
  254.         (declare (ignore slotd))
  255.         (let ((value (cdr index)))
  256.           (if (eq value *slot-unbound*)
  257.               (slot-unbound class instance slot-name)
  258.               value))))))
  259.  
  260. (defun make-optimized-std-setf-slot-value-using-class-method-function
  261.     (fsc-p slot-name index)
  262.   (declare #.*optimize-speed*)
  263.   (declare (ignore slot-name))
  264.   (etypecase index
  265.     (fixnum (if fsc-p
  266.         #'(lambda (nv class instance slotd)
  267.             (declare (ignore class slotd))
  268.             (setf (%instance-ref (fsc-instance-slots instance) index) nv))
  269.         #'(lambda (nv class instance slotd)
  270.             (declare (ignore class slotd))
  271.             (setf (%instance-ref (std-instance-slots instance) index) nv))))
  272.     (cons   #'(lambda (nv class instance slotd)
  273.         (declare (ignore class instance slotd))
  274.         (setf (cdr index) nv)))))
  275.  
  276. (defun make-optimized-std-slot-boundp-using-class-method-function
  277.     (fsc-p slot-name index)
  278.   (declare #.*optimize-speed*)
  279.   (declare (ignore slot-name))
  280.   (etypecase index
  281.     (fixnum (if fsc-p
  282.         #'(lambda (class instance slotd)
  283.             (declare (ignore class slotd))
  284.             (not (eq *slot-unbound* 
  285.                  (%instance-ref (fsc-instance-slots instance) index))))
  286.         #'(lambda (class instance slotd)
  287.             (declare (ignore class slotd))
  288.             (not (eq *slot-unbound* 
  289.                  (%instance-ref (std-instance-slots instance) index))))))
  290.     (cons   #'(lambda (class instance slotd)
  291.         (declare (ignore class instance slotd))
  292.         (not (eq *slot-unbound* (cdr index)))))))
  293.  
  294. (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
  295.   (macrolet ((emf-funcall (emf &rest args)
  296.            `(invoke-effective-method-function ,emf nil ,@args)))
  297.     (set-function-name
  298.      (case name
  299.        (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
  300.        (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
  301.        (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
  302.      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
  303.  
  304. (defun make-internal-reader-method-function (class-name slot-name)
  305.   (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
  306.      (make-method-function
  307.       (lambda (instance)
  308.         (let ((wrapper (cond ((std-instance-p instance) 
  309.                   (std-instance-wrapper instance))
  310.                  ((fsc-instance-p instance) 
  311.                   (fsc-instance-wrapper instance)))))
  312.           (if wrapper
  313.           (let* ((class (wrapper-class* wrapper))
  314.              (index (or (instance-slot-index wrapper slot-name)
  315.                     (assq slot-name (wrapper-class-slots wrapper)))))
  316.             (typecase index
  317.               (fixnum     
  318.                (let ((value (%instance-ref (get-slots instance) index)))
  319.              (if (eq value *slot-unbound*)
  320.                  (slot-unbound (class-of instance) instance slot-name)
  321.                  value)))
  322.               (cons
  323.                (let ((value (cdr index)))
  324.              (if (eq value *slot-unbound*)
  325.                  (slot-unbound (class-of instance) instance slot-name)
  326.                  value)))
  327.               (t
  328.                (error "The wrapper for class ~S does not have the slot ~S"
  329.                   class slot-name))))
  330.           (slot-value instance slot-name)))))))
  331.  
  332.  
  333. (defun make-std-reader-method-function (class-name slot-name)
  334.   (let* ((pv-table-symbol (gensym))
  335.      (initargs (copy-tree
  336.             (make-method-function
  337.              (lambda (instance)
  338.                (pv-binding1 (.pv. .calls.
  339.                       (symbol-value pv-table-symbol)
  340.                       (instance) (instance-slots))
  341.              (instance-read-internal 
  342.               .pv. instance-slots 1
  343.               (slot-value instance slot-name))))))))
  344.     (setf (getf (getf initargs ':plist) ':slot-name-lists)
  345.       (list (list nil slot-name)))
  346.     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
  347.     (list* ':method-spec `(reader-method ,class-name ,slot-name)
  348.        initargs)))
  349.  
  350. (defun make-std-writer-method-function (class-name slot-name)
  351.   (let* ((pv-table-symbol (gensym))
  352.      (initargs (copy-tree
  353.             (make-method-function
  354.              (lambda (nv instance)
  355.                (pv-binding1 (.pv. .calls.
  356.                       (symbol-value pv-table-symbol)
  357.                       (instance) (instance-slots))
  358.              (instance-write-internal 
  359.               .pv. instance-slots 1 nv
  360.               (setf (slot-value instance slot-name) nv))))))))
  361.     (setf (getf (getf initargs ':plist) ':slot-name-lists)
  362.       (list nil (list nil slot-name)))
  363.     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
  364.     (list* ':method-spec `(writer-method ,class-name ,slot-name)
  365.        initargs)))
  366.  
  367. (defun make-std-boundp-method-function (class-name slot-name)
  368.   (let* ((pv-table-symbol (gensym))
  369.      (initargs (copy-tree
  370.             (make-method-function
  371.              (lambda (instance)
  372.                (pv-binding1 (.pv. .calls.
  373.                       (symbol-value pv-table-symbol)
  374.                       (instance) (instance-slots))
  375.               (instance-boundp-internal 
  376.                .pv. instance-slots 1
  377.                (slot-boundp instance slot-name))))))))
  378.     (setf (getf (getf initargs ':plist) ':slot-name-lists)
  379.       (list (list nil slot-name)))
  380.     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
  381.     (list* ':method-spec `(boundp-method ,class-name ,slot-name)
  382.        initargs)))
  383.  
  384. (defun initialize-internal-slot-gfs (slot-name &optional type)
  385.   (when (or (null type) (eq type 'reader))
  386.     (let* ((name (slot-reader-symbol slot-name))
  387.        (gf (ensure-generic-function name)))
  388.       (unless (generic-function-methods gf)
  389.     (add-reader-method *the-class-slot-object* gf slot-name))))
  390.   (when (or (null type) (eq type 'writer))
  391.     (let* ((name (slot-writer-symbol slot-name))
  392.        (gf (ensure-generic-function name)))
  393.       (unless (generic-function-methods gf)
  394.     (add-writer-method *the-class-slot-object* gf slot-name))))
  395.   (when (and *optimize-slot-boundp*
  396.          (or (null type) (eq type 'boundp)))
  397.     (let* ((name (slot-boundp-symbol slot-name))
  398.        (gf (ensure-generic-function name)))
  399.       (unless (generic-function-methods gf)
  400.     (add-boundp-method *the-class-slot-object* gf slot-name))))
  401.   nil)
  402.  
  403. (defun initialize-internal-slot-gfs* (readers writers boundps)
  404.   (dolist (reader readers)
  405.     (initialize-internal-slot-gfs reader 'reader))
  406.   (dolist (writer writers)
  407.     (initialize-internal-slot-gfs writer 'writer))
  408.   (dolist (boundp boundps)
  409.     (initialize-internal-slot-gfs boundp 'boundp)))
  410.